home *** CD-ROM | disk | FTP | other *** search
/ Info-Mac 4 / Info_Mac IV CD-ROM (Pacific HiTech Inc.)(August 1994).iso / Development / General / ViewIt™ 2.24 Shareware / FORTRAN Demo Projects / LS Fortran 3.3 Demos / FaceProcLF.inc next >
Text File  |  1993-09-20  |  3KB  |  119 lines
  1. C FaceWare 2.2 Initialization & Dispatching Procedures
  2. C ©FaceWare 1989-93.  All Rights Reserved.
  3.  
  4. C NOTE: To compile this file as a separate object, you'll need
  5. C to add the "!!M Inlines.f" directive seen in the demo program.
  6.  
  7.     SUBROUTINE fJumpIt(theProc,thePtr)
  8.     integer*4 thePtr
  9.     call theProc(%val(thePtr))
  10.     return
  11.     end
  12.  
  13.     SUBROUTINE FaceIt(xPtr,m1,m2,m3,m4,m5)
  14.     implicit none
  15. C NOTE: If you use the "!!G" directive for precompiled globals, add
  16. C our FaceStorLF.inc globals to yours and then remove following line
  17.     include 'FaceStorLF.inc'
  18.       record /FaceRec/ fRec
  19.       common/FaceStuff/fRec
  20.     structure /HeadRec/
  21.       integer*4 addr
  22.       integer*2 baseID
  23.       integer*2 versID
  24.       integer*2 message
  25.       integer*2 resID
  26.       integer*4 fPtr
  27.     end structure
  28.     pointer /HeadRec/ thePtr
  29.     character*4 restype
  30.     integer*4 xPtr,m1,m2,m3,m4,m5,i,fPtr
  31.     thePtr = xPtr
  32.     fPtr = %loc(fRec)
  33.     if (m1 = -61) then
  34.       if ((m4 > -1).and.(.not.BTEST(m4,0))) then
  35.         !ignore spurious mouse & key events
  36.         call FlushEvents(%val(int2(62)),%val(int2(0)))
  37.       end if
  38.       restype = 'FCMD'           !find LoadIt or quit to Finder        
  39.       if (GetResource(%val(restype),%val(int2(1000))) = 0) then
  40.         if (OpenResFile(%val(trim(fRec.uName))) < 0) stop
  41.       end if
  42.       fRec.fFlags = m2         !store FaceIt bit flags
  43.       fRec.xEntries = m5         !store # of table entries
  44.       thePtr = fPtr
  45.       if (m3 > -1) then           !call LoadIt to expand heap?
  46.         call PrepIt(thePtr,m3,0,0,thePtr)
  47.         call fJumpIt(%val(long(thePtr)),thePtr)
  48.       end if
  49.       call PrepIt(thePtr,1100,22,0,thePtr)      !setup fRec header
  50.       call PrepIt(thePtr+1002,1210,22,0,thePtr) !setup uRec header
  51.       call PrepIt(thePtr+1634,1200,22,0,thePtr) !setup vRec header
  52.       fRec.fHead(6) = m4           !store environment type
  53.       fRec.uHead(6) = 2            !establish string type
  54.       thePtr = 0
  55.       if (m4 < -3) return
  56.     end if
  57.     if (m1 = -62) then
  58.       call PrepIt(m2,m3,m4,m5,fPtr)
  59.     else if ((m1 < 0).and.(m1 > -11)) then
  60.       i = (4 * (-1 - m1))
  61.       fRec.xTable(1+i) = m2
  62.       fRec.xTable(2+i) = m3
  63.       fRec.xTable(3+i) = m4
  64.       fRec.xTable(4+i) = m5
  65.     else
  66.       if (thePtr = 0) then       !call to default module?
  67.         thePtr = fPtr + 1002
  68.       else if (thePtr^.fPtr <> fPtr) then
  69.         fRec.cControl = thePtr   !call to control driver?
  70.         thePtr = fPtr + 1634
  71.       end if
  72.       thePtr^.message = 0
  73.       fRec.uCommand = m1         !pass Command & Params
  74.       fRec.uParam(1) = m2
  75.       fRec.uParam(2) = m3
  76.       fRec.uParam(3) = m4
  77.       fRec.uParam(4) = m5
  78.       call fJumpIt(%val(long(thePtr)),thePtr) !jump to FCMD
  79.     end if
  80.     end
  81.  
  82.     SUBROUTINE PrepIt(x,b,v,r,f)
  83.     implicit none
  84. C NOTE: If you use the "!!G" directive for precompiled globals, add
  85. C our FaceStorLF.inc globals to yours and then remove following line
  86.     include 'FaceStorLF.inc'
  87.       record /FaceRec/ fRec
  88.       common/FaceStuff/fRec
  89.     structure /HeadRec/
  90.       integer*4 addr
  91.       integer*2 baseID
  92.       integer*2 versID
  93.       integer*2 message
  94.       integer*2 resID
  95.       integer*4 fPtr
  96.     end structure
  97.     pointer /HeadRec/ x
  98.     integer*4 b,v,r,f,i
  99.     character*4 restype
  100.     restype = 'FCMD'
  101.     x^.addr = long(GetResource(%val(restype),%val(int2(1000))))
  102.     x^.baseID = b
  103.     x^.versID = v
  104.     x^.message = 0
  105.     x^.resID = r
  106.     x^.fPtr = f
  107.     if (fRec.xEntries > 0) then
  108.      do i = 0, fRec.xEntries-1
  109.       if (b = fRec.xTable(1 + 4*i)) then
  110.        if (v = fRec.xTable(2 + 4*i)) then
  111.         if (0 <> fRec.xTable(4 + 4*i)) then
  112.          x^.addr = fRec.xTable(4 + 4*i)
  113.         end if
  114.        end if
  115.       end if
  116.      end do
  117.     end if
  118.     end
  119.